home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue40 / Threads / HVSounds.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-11-05  |  4.4 KB  |  160 lines
  1. unit HVSounds;
  2. //
  3. // Written by Hallvard Vassbotn, hallvard@falcon.no
  4. //
  5. // Based on source code Copyright (c) 1998 by Reuters Group PLC
  6. // Reproduction and/or distribution of source code or DCUs strictly prohibited.
  7. //
  8. // For publication in The Delphi Magazine only
  9. //
  10. interface
  11.  
  12. uses
  13.   HVBackgroudThread
  14.   ;
  15.  
  16. const
  17.   MaxSounds = 12;
  18. type
  19.   TPlaySoundTask = class(TBackgroundTask)
  20.   private
  21.     FSoundIndex: integer;
  22.   protected
  23.     procedure Perform; override;
  24.   public
  25.     // Runs in main context
  26.     constructor CreateInit(aSoundIndex: integer; aOnSoundDone: TTaskDoneEvent);
  27.     property SoundIndex: integer read FSoundIndex;
  28.   end;
  29.  
  30. function PlaySoundThread: TBackgroundTasksThread;
  31.  
  32. //procedure PlaySoundIndex(aSoundIndex: integer; aOnSoundDone: TTaskDoneEvent);
  33. procedure PlaySoundIndex(aSoundIndex: integer; aOnSoundDone: TTaskDoneEvent; Multithreaded: boolean);
  34.  
  35. implementation
  36.  
  37. uses
  38.   Classes,
  39.   Windows,
  40.   MMSystem,
  41.   SysUtils,
  42.   HVUtils
  43.   ;
  44.  
  45. { Basic PC-speaker routines }
  46.  
  47. type
  48.   TSoundRec = packed record
  49.     OL: byte;      // Outer Loop iterations
  50.     IL: byte;      // Inner Loop iterations
  51.     B1: smallint;      // Base frequencies, -1 for no sound
  52.     B2: smallint;
  53.     B3: smallint;
  54.     F1: shortint;  // Factor for each freqency (* with inner loop index)
  55.     F2: shortint;
  56.     F3: shortint;
  57.     Dr: byte;      // Duration of each sound
  58.   end;
  59.  
  60. const
  61.   // Table-driven internal speaker sounds
  62.   SoundsArr : array[1..MaxSounds] of TSoundRec =
  63.   ((OL: 02; IL: 10; B1: 3000; B2: 3000; B3:   -1; F1: 30; F2:-30; F3: 00; Dr: 10),  //Sound 1
  64.    (OL: 00; IL: 15; B1: 1000; B2: 5500; B3:   -1; F1: 00; F2: 00; F3: 00; Dr: 10),  //Sound 2
  65.    (OL: 00; IL: 02; B1:  500; B2: 1000; B3: 1500; F1: 00; F2: 00; F3: 00; Dr: 40),  //Sound 3
  66.    (OL: 00; IL: 02; B1:  300; B2:  500; B3:   -1; F1: 00; F2: 00; F3: 60; Dr: 60),  //Sound 4
  67.    (OL: 00; IL: 50; B1: 0000; B2:   -1; B3:   -1; F1: 20; F2: 00; F3: 00; Dr:  2),  //Sound 5
  68.    (OL: 00; IL: 50; B1: 1000; B2:   -1; B3:   -1; F1:-20; F2: 00; F3: 00; Dr:  2),  //Sound 6
  69.    (OL: 00; IL: 50; B1: 1000; B2:   -1; B3:   -1; F1: 20; F2: 00; F3: 00; Dr:  2),  //Sound 7
  70.    (OL: 00; IL: 50; B1: 2000; B2:   -1; B3:   -1; F1:-20; F2: 00; F3: 00; Dr:  2),  //Sound 8
  71.    (OL: 00; IL: 00; B1:  700; B2:   -1; B3:   -1; F1: 00; F2: 00; F3: 00; Dr:255),  //Sound 9
  72.    (OL: 00; IL: 00; B1:  300; B2:   -1; B3:   -1; F1: 00; F2: 00; F3: 00; Dr:255),  //Sound 10
  73.    (OL: 02; IL: 10; B1:  500; B2:  500; B3:   -1; F1: 30; F2:-30; F3: 00; Dr: 10),  //Sound 11
  74.    (OL: 01; IL: 10; B1:  500; B2: 3500; B3: 1200; F1: 40; F2:-60; F3:-10; Dr:  5)   //Sound 12
  75.   );
  76.  
  77. procedure SoundFreq(Freq, Dur: integer);
  78. begin
  79.   Windows.Beep(Freq, Dur);
  80. end;
  81.  
  82. procedure SoundOff;
  83. begin
  84.   Windows.Beep(0, 0);
  85. end;
  86.  
  87. procedure PlaySoundRec(const SoundRec: TSoundRec);
  88. var
  89.   i: integer;
  90.   j: integer;
  91. begin
  92.   with SoundRec do
  93.   begin
  94.     for i := 0 to OL do
  95.       for j := 0 to IL do
  96.       begin
  97.         if B1 >= 0 then SoundFreq(B1 + (F1 * j), Dr);
  98.         if B2 >= 0 then SoundFreq(B2 + (F2 * j), Dr);
  99.         if B3 >= 0 then SoundFreq(B3 + (F3 * j), Dr);
  100.       end;
  101.     SoundOff;
  102.   end;
  103. end;
  104.  
  105. procedure SoundAlarm(SoundIndex: integer);
  106. begin
  107.   if (SoundIndex >= 1) and (SoundIndex <= MaxSounds) then
  108.     PlaySoundRec(SoundsArr[SoundIndex])
  109.   else
  110.     Windows.MessageBeep($FFFFFFFF);
  111. end;
  112.  
  113. { TPlaySoundTask }
  114.  
  115. constructor TPlaySoundTask.CreateInit(aSoundIndex: integer; aOnSoundDone: TTaskDoneEvent);
  116. begin
  117.   inherited Create;
  118.   OnTaskDone := aOnSoundDone;
  119.   FSoundIndex := aSoundIndex;
  120. end;
  121.  
  122. procedure TPlaySoundTask.Perform;
  123. begin
  124.   SoundAlarm(SoundIndex);
  125. end;
  126.  
  127. { Singleton interface }
  128.  
  129. var
  130.   PlaySoundThreadInstance: TBackgroundTasksThread = nil;
  131.  
  132. function PlaySoundThread: TBackgroundTasksThread;
  133. begin
  134.   if not Assigned(PlaySoundThreadInstance) then
  135.     PlaySoundThreadInstance:= TBackgroundTasksThread.Create;
  136.   Result := PlaySoundThreadInstance;
  137. end;
  138.  
  139. { Simplified Sound API }
  140.  
  141. procedure PlaySoundIndex(aSoundIndex: integer; aOnSoundDone: TTaskDoneEvent; Multithreaded: boolean);
  142. var
  143.   Task: TPlaySoundTask;
  144. begin
  145.   Task := TPlaySoundTask.CreateInit(aSoundIndex, aOnSoundDone);
  146.   if Multithreaded then
  147.     PlaySoundThread.AddBackgroundTask(Task)
  148.   else
  149.   begin
  150.     Task.Perform;
  151.     Task.Done;
  152.     Task.Free;
  153.   end;
  154. end;
  155.  
  156. initialization
  157. finalization
  158.   FreeObject(PlaySoundThreadInstance);
  159. end.
  160.